home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 7_2009-2012.ISO / data / zips / Function_D2181165152010.psc / Function Drawer / Class Modules / FontDialog.cls < prev    next >
Text File  |  2010-04-06  |  15KB  |  489 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "FontDialog"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14. Public Enum CharSets
  15.     ANSICharSet = 0
  16.     DefaultCharSet = 1
  17.     SymbolCharSet = 2
  18.     MacCharSet = 77
  19.     ShiftjisCharSet = 128
  20.     HangeulCharSet = 129
  21.     HangulCharSet = 129
  22.     JohabCharSet = 130
  23.     ChineseGB2312CharSet = 134
  24.     ChineseBig5CharSet = 136
  25.     GreekCharSet = 161
  26.     TurkishCharSet = 162
  27.     VietnameseCharSet = 163
  28.     HebrewCharSet = 177
  29.     ArabicCharSet = 178
  30.     BalticCharSet = 186
  31.     RussianCharSet = 204
  32.     ThaiCharSet = 222
  33.     EastEuropeCharSet = 238
  34.     OEMCharSet = 255
  35. End Enum
  36.  
  37. Private Const LF_FACESize = 32
  38. Private Type LOGFONT
  39.         lfHeight As Long
  40.         lfWidth As Long
  41.         lfEscapement As Long
  42.         lfOrientation As Long
  43.         lfWeight As Long
  44.         lfItalic As Byte
  45.         lfUnderline As Byte
  46.         lfStrikeOut As Byte
  47.         lfCharSet As Byte
  48.         lfOutPrecision As Byte
  49.         lfClipPrecision As Byte
  50.         lfQuality As Byte
  51.         lfPitchAndFamily As Byte
  52.         lfFaceName(1 To LF_FACESize) As Byte
  53. End Type
  54.  
  55. Private Type ChooseFont
  56.         lStructSize As Long
  57.         hwndOwner As Long          '  caller's window handle
  58.         hdc As Long                '  printer DC/IC or NULL
  59.         lpLogFont As Long
  60.         iPointSize As Long         '  10 * Size in points of selected font
  61.         Flags As Long              '  enum. type flags
  62.         rgbColors As Long          '  returned text color
  63.         lCustData As Long          '  data passed to hook fn.
  64.         lpfnHook As Long           '  ptr. to hook function
  65.         lpTemplateName As String     '  custom template name
  66.         hInstance As Long          '  instance handle of.EXE that
  67.                                        '    contains cust. dlg. template
  68.         lpszStyle As String          '  return the style field here
  69.                                        '  must be LF_FACESize or bigger
  70.         nFontType As Integer          '  same value reported to the EnumFonts
  71.                                        '    call back with the extra FONTTYPE_
  72.                                        '    bits added
  73.         MISSING_ALIGNMENT As Integer
  74.         nSizeMin As Long           '  minimum pt Size allowed &
  75.         nSizeMax As Long           '  max pt Size allowed if
  76.                                        '    CF_LIMITSize is used
  77. End Type
  78.  
  79. Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As ChooseFont) As Long
  80.  
  81. Const CF_SCREENFONTS = &H1
  82. Const CF_PRINTERFONTS = &H2
  83. Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
  84. Const CF_SHOWHELP = &H4&
  85. Const CF_ENABLEHOOK = &H8&
  86. Const CF_ENABLETEMPLATE = &H10&
  87. Const CF_ENABLETEMPLATEHANDLE = &H20&
  88. Const CF_INITTOLOGFONTStrUCT = &H40&
  89. Const CF_USESTYLE = &H80&
  90. Const CF_EFFECTS = &H100&
  91. Const CF_APPLY = &H200&
  92. Const CF_ANSIONLY = &H400&
  93. Const CF_NOVECTORFONTS = &H800&
  94. Const CF_NOOEMFONTS = CF_NOVECTORFONTS
  95. Const CF_NOSIMULATIONS = &H1000&
  96. Const CF_LIMITSize = &H2000&
  97. Const CF_FIXEDPITCHONLY = &H4000&
  98. Const CF_WYSIWYG = &H8000 '  must also have CF_SCREENFONTS CF_PRINTERFONTS
  99. Const CF_FORCEFONTEXIST = &H10000
  100. Const CF_SCALABLEONLY = &H20000
  101. Const CF_TTONLY = &H40000
  102. Const CF_NOFACESEL = &H80000
  103. Const CF_NOSTYLESEL = &H100000
  104. Const CF_NOSizeSEL = &H200000
  105. Const CF_SELECTSCRIPT = &H400000
  106. Const CF_NOSCRIPTSEL = &H800000
  107. Const CF_NOVERTFONTS = &H1000000
  108.  
  109. Const SIMULATED_FONTTYPE = &H8000
  110. Const PRINTER_FONTTYPE = &H4000
  111. Const SCREEN_FONTTYPE = &H2000
  112. Const BOLD_FONTTYPE = &H100
  113. Const ITALIC_FONTTYPE = &H200
  114. Const REGULAR_FONTTYPE = &H400
  115.  
  116. Dim cfOK As Boolean
  117. Dim cfCancel As Boolean
  118. Dim cfChooseFont As ChooseFont
  119. Dim cfLogFont As LOGFONT
  120. Dim cfhWndOwner As Long
  121. Dim cfFontSize As Long
  122. Dim cfFontColor As Long
  123. Dim cfScreenFonts As Boolean
  124. Dim cfPrinterFonts As Boolean
  125. 'Dim cfShowCommonPrinterAndScreenFonts As Boolean
  126. Dim cfMinimumSize As Long
  127. Dim cfMaximumSize As Long
  128. Dim cfTrueTypeFontsOnly As Boolean
  129. Dim cfShowEffects As Boolean
  130. Dim cfANSICharSetOnly As Boolean
  131. Dim cfFixedPitchFontsOnly As Boolean
  132. Dim cfScalableFontsOnly As Boolean
  133. Dim cfFontNotExistPrompt As Boolean
  134. Dim cfShowHiddenFonts As Boolean
  135. Dim cfInitializeFontProperties As Boolean
  136. Dim cfLimitFontSize As Boolean
  137. Dim cfDontShowVectorFonts As Boolean
  138. Dim cfDontInitFontName As Boolean
  139. Dim cfDontInitFontStyle As Boolean
  140. Dim cfDontInitFontSize As Boolean
  141. Dim cfNoVerticalFonts As Boolean
  142. Dim cfShowHelpButton As Boolean
  143. Dim cfSpecifyCharsets As Boolean
  144. Dim cfDisableCharSet As Boolean
  145.  
  146. Friend Property Get hwndOwner() As Long
  147.     hwndOwner = cfhWndOwner
  148. End Property
  149.     
  150. Friend Property Let hwndOwner(ByVal vNewValue As Long)
  151.     cfhWndOwner = vNewValue
  152. End Property
  153.  
  154. Friend Property Get FontSize() As Long
  155.     FontSize = Abs(cfLogFont.lfHeight * 3 / 4)
  156. End Property
  157.  
  158. Friend Property Let FontSize(ByVal vNewValue As Long)
  159.     cfLogFont.lfHeight = Abs(vNewValue * 4 / 3)
  160. End Property
  161.  
  162. Friend Property Get FontColor() As Long
  163.     FontColor = cfChooseFont.rgbColors
  164. End Property
  165.  
  166. Friend Property Let FontColor(ByVal vNewValue As Long)
  167.     cfChooseFont.rgbColors = vNewValue
  168. End Property
  169.  
  170. Friend Property Get FontName() As String
  171.     Dim i As Integer
  172.     Dim retVal As String
  173.     For i = 1 To 32
  174.         retVal = retVal & Chr$(cfLogFont.lfFaceName(i))
  175.     Next
  176.     FontName = Replace(retVal, Chr$(0), "")
  177. End Property
  178.  
  179. Friend Property Let FontName(ByVal vNewValue As String)
  180.     Dim i As Integer
  181.     For i = 1 To 32
  182.         cfLogFont.lfFaceName(i) = 0
  183.     Next
  184.     For i = 1 To Len(vNewValue)
  185.         cfLogFont.lfFaceName(i) = Asc(Mid(vNewValue, i, 1))
  186.     Next
  187. End Property
  188.  
  189. Friend Property Get FontBold() As Boolean
  190.     If cfLogFont.lfWeight = 400 Then
  191.         FontBold = False
  192.     ElseIf cfLogFont.lfWeight = 700 Then
  193.         FontBold = True
  194.     End If
  195. End Property
  196.  
  197. Friend Property Let FontBold(ByVal vNewValue As Boolean)
  198.     If vNewValue = True Then
  199.         cfLogFont.lfWeight = 700
  200.     ElseIf vNewValue = False Then
  201.         cfLogFont.lfWeight = 400
  202.     End If
  203. End Property
  204.  
  205. Friend Property Get FontItalic() As Boolean
  206.     FontItalic = cfLogFont.lfItalic
  207. End Property
  208.  
  209. Friend Property Let FontItalic(ByVal vNewValue As Boolean)
  210.     cfLogFont.lfItalic = vNewValue
  211. End Property
  212.  
  213. Friend Property Get FontUnderLine() As Boolean
  214.     FontUnderLine = cfLogFont.lfUnderline
  215. End Property
  216.  
  217. Friend Property Let FontUnderLine(ByVal vNewValue As Boolean)
  218.     cfLogFont.lfUnderline = vNewValue
  219. End Property
  220.  
  221. Friend Property Get FontStrikeThrough() As Boolean
  222.     FontStrikeThrough = cfLogFont.lfStrikeOut
  223. End Property
  224.  
  225. Friend Property Let FontStrikeThrough(ByVal vNewValue As Boolean)
  226.     cfLogFont.lfStrikeOut = vNewValue
  227. End Property
  228.  
  229. Friend Property Get FontCharSet() As Long
  230.     FontCharSet = cfLogFont.lfCharSet
  231. End Property
  232.  
  233. Friend Property Let FontCharSet(ByVal vNewValue As Long)
  234.     cfLogFont.lfCharSet = vNewValue
  235. End Property
  236. Friend Property Get SpecifyCharsets() As Boolean
  237.     SpecifyCharsets = cfSpecifyCharsets
  238. End Property
  239.  
  240. Friend Property Let SpecifyCharsets(ByVal vNewValue As Boolean)
  241.     cfSpecifyCharsets = vNewValue
  242. End Property
  243.  
  244. Friend Property Get DisableCharSet() As Boolean
  245.     DisableCharSet = cfDisableCharSet
  246. End Property
  247.  
  248. Friend Property Let DisableCharSet(ByVal vNewValue As Boolean)
  249.     cfDisableCharSet = vNewValue
  250. End Property
  251.  
  252. Friend Property Get ShowScreenFonts() As Boolean
  253.     ShowScreenFonts = cfScreenFonts
  254. End Property
  255.  
  256. Friend Property Let ShowScreenFonts(ByVal vNewValue As Boolean)
  257.     cfScreenFonts = vNewValue
  258. End Property
  259.  
  260. Friend Property Get ShowPrinterFonts() As Boolean
  261.     ShowPrinterFonts = cfPrinterFonts
  262. End Property
  263.  
  264. Friend Property Let ShowPrinterFonts(ByVal vNewValue As Boolean)
  265.     cfPrinterFonts = vNewValue
  266. End Property
  267.  
  268. Friend Property Get MinimumSize() As Long
  269.     MinimumSize = cfMinimumSize
  270. End Property
  271.  
  272. Friend Property Let MinimumSize(ByVal vNewValue As Long)
  273.     cfMinimumSize = vNewValue
  274. End Property
  275.  
  276. Friend Property Get MaximumSize() As Long
  277.     cfMaximumSize = MaximumSize
  278. End Property
  279.  
  280. Friend Property Let MaximumSize(ByVal vNewValue As Long)
  281.     cfMaximumSize = vNewValue
  282. End Property
  283.  
  284. Friend Property Get TrueTypeFontsOnly() As Boolean
  285.     TrueTypeFontsOnly = cfTrueTypeFontsOnly
  286. End Property
  287.  
  288. Friend Property Let TrueTypeFontsOnly(ByVal vNewValue As Boolean)
  289.     cfTrueTypeFontsOnly = vNewValue
  290. End Property
  291.  
  292. Friend Property Get ANSICharSetOnly() As Boolean
  293.     ANSICharSetOnly = cfANSICharSetOnly
  294. End Property
  295.  
  296. Friend Property Let ANSICharSetOnly(ByVal vNewValue As Boolean)
  297.     cfANSICharSetOnly = vNewValue
  298. End Property
  299. Friend Property Get ShowEffects() As Boolean
  300.     ShowEffects = cfShowEffects
  301. End Property
  302.  
  303. Friend Property Let ShowEffects(ByVal vNewValue As Boolean)
  304.     cfShowEffects = vNewValue
  305. End Property
  306.  
  307. Friend Property Get FixedPitchFontsOnly() As Boolean
  308.     FixedPitchFontsOnly = cfFixedPitchFontsOnly
  309. End Property
  310.  
  311. Friend Property Let FixedPitchFontsOnly(ByVal vNewValue As Boolean)
  312.     cfFixedPitchFontsOnly = vNewValue
  313. End Property
  314.  
  315. Friend Property Get ScalableFontsOnly() As Boolean
  316.     ScalableFontsOnly = cfScalableFontsOnly
  317. End Property
  318.  
  319. Friend Property Let ScalableFontsOnly(ByVal vNewValue As Boolean)
  320.     cfScalableFontsOnly = vNewValue
  321. End Property
  322.  
  323. Friend Property Get FontNotExistPrompt() As Boolean
  324.     FontNotExistPrompt = cfFontNotExistPrompt
  325. End Property
  326.  
  327. Friend Property Let FontNotExistPrompt(ByVal vNewValue As Boolean)
  328.     cfFontNotExistPrompt = vNewValue
  329. End Property
  330.  
  331. Friend Property Get ShowHiddenFonts() As Boolean
  332.     ShowHiddenFonts = cfShowHiddenFonts
  333. End Property
  334.  
  335. Friend Property Let ShowHiddenFonts(ByVal vNewValue As Boolean)
  336.     cfShowHiddenFonts = vNewValue
  337. End Property
  338.  
  339. Friend Property Get InitializeFontProperties() As Boolean
  340.     InitializeFontProperties = cfInitializeFontProperties
  341. End Property
  342.  
  343. Friend Property Let InitializeFontProperties(ByVal vNewValue As Boolean)
  344.     cfInitializeFontProperties = vNewValue
  345. End Property
  346.  
  347. Friend Property Get LimitFontSize() As Boolean
  348.     LimitFontSize = cfLimitFontSize
  349. End Property
  350.  
  351. Friend Property Let LimitFontSize(ByVal vNewValue As Boolean)
  352.     cfLimitFontSize = vNewValue
  353. End Property
  354.  
  355. Friend Property Get DontShowVectorFonts() As Boolean
  356.     DontShowVectorFonts = cfDontShowVectorFonts
  357. End Property
  358.  
  359. Friend Property Let DontShowVectorFonts(ByVal vNewValue As Boolean)
  360.     cfDontShowVectorFonts = vNewValue
  361. End Property
  362.  
  363. Friend Property Get NoVerticalFonts() As Boolean
  364.     NoVerticalFonts = cfNoVerticalFonts
  365. End Property
  366.  
  367. Friend Property Let NoVerticalFonts(ByVal vNewValue As Boolean)
  368.     cfNoVerticalFonts = vNewValue
  369. End Property
  370.  
  371. Friend Property Get DontInitFontName() As Boolean
  372.     DontInitFontName = cfDontInitFontName
  373. End Property
  374.  
  375. Friend Property Let DontInitFontName(ByVal vNewValue As Boolean)
  376.     cfDontInitFontName = vNewValue
  377. End Property
  378.  
  379. Friend Property Get DontInitFontStyle() As Boolean
  380.     DontInitFontStyle = cfDontInitFontStyle
  381. End Property
  382.  
  383. Friend Property Let DontInitFontStyle(ByVal vNewValue As Boolean)
  384.     cfDontInitFontStyle = vNewValue
  385. End Property
  386.  
  387. Friend Property Get DontInitFontSize() As Boolean
  388.     DontInitFontSize = cfDontInitFontSize
  389. End Property
  390.  
  391. Friend Property Let DontInitFontSize(ByVal vNewValue As Boolean)
  392.     cfDontInitFontSize = vNewValue
  393. End Property
  394.  
  395. Friend Property Get ShowHelpButton() As Boolean
  396.     ShowHelpButton = cfShowHelpButton
  397. End Property
  398.  
  399. Friend Property Let ShowHelpButton(ByVal vNewValue As Boolean)
  400.     cfShowHelpButton = vNewValue
  401. End Property
  402.  
  403. Friend Property Get OK() As Boolean
  404.     OK = cfOK
  405. End Property
  406.  
  407. Friend Property Get Cancel() As Boolean
  408.     Cancel = cfCancel
  409. End Property
  410.  
  411. Friend Property Get DialogTitle() As String
  412.     DialogTitle = CommonDialogsHooks.CFDialogTitle
  413. End Property
  414.  
  415. Friend Property Let DialogTitle(ByVal vNewValue As String)
  416.    CommonDialogsHooks.CFDialogTitle = vNewValue
  417. End Property
  418.  
  419. Friend Property Get OKButtonCaption() As String
  420.     OKButtonCaption = CommonDialogsHooks.CFOKButtonCaption
  421. End Property
  422.  
  423. Friend Property Let OKButtonCaption(ByVal vNewValue As String)
  424.    CommonDialogsHooks.CFOKButtonCaption = vNewValue
  425. End Property
  426.  
  427. Friend Property Get CancelButtonCaption() As String
  428.     CancelButtonCaption = CommonDialogsHooks.CFCancelButtonCaption
  429. End Property
  430.  
  431. Friend Property Let CancelButtonCaption(ByVal vNewValue As String)
  432.    CommonDialogsHooks.CFCancelButtonCaption = vNewValue
  433. End Property
  434.  
  435. Friend Property Get EnableColorComboBox() As Boolean
  436.     EnableColorComboBox = CommonDialogsHooks.CFEnableColorComboBox
  437. End Property
  438.  
  439. Friend Property Let EnableColorComboBox(ByVal vNewValue As Boolean)
  440.    CommonDialogsHooks.CFEnableColorComboBox = vNewValue
  441. End Property
  442.  
  443. Public Sub ShowDialog()
  444.     Dim SaveLogFont As LOGFONT
  445.     SaveLogFont = cfLogFont
  446.     With cfChooseFont
  447.         
  448.         .Flags = CLng(Abs(cfScreenFonts * CF_SCREENFONTS) Or _
  449.                 Abs(cfPrinterFonts * CF_PRINTERFONTS) Or _
  450.                 Abs(cfShowHelpButton * CF_SHOWHELP) Or _
  451.                 Abs(cfTrueTypeFontsOnly * CF_TTONLY) Or _
  452.                 Abs(cfInitializeFontProperties * CF_INITTOLOGFONTStrUCT) Or _
  453.                 Abs(cfShowEffects * CF_EFFECTS) Or _
  454.                 Abs(cfANSICharSetOnly * CF_ANSIONLY) Or _
  455.                 Abs(cfDontShowVectorFonts * CF_NOVECTORFONTS) Or _
  456.                 Abs(cfLimitFontSize * CF_LIMITSize) Or _
  457.                 Abs(cfFixedPitchFontsOnly * CF_FIXEDPITCHONLY) Or _
  458.                 Abs(cfFontNotExistPrompt * CF_FORCEFONTEXIST) Or _
  459.                 Abs(cfScalableFontsOnly * CF_SCALABLEONLY) Or _
  460.                 Abs(cfDontInitFontName * CF_NOFACESEL) Or _
  461.                 Abs(cfDontInitFontStyle * CF_NOSTYLESEL) Or _
  462.                 Abs(cfDontInitFontSize * CF_NOSizeSEL) Or _
  463.                 Abs(cfDisableCharSet * CF_NOSCRIPTSEL) Or _
  464.                 Abs(cfSpecifyCharsets * CF_SELECTSCRIPT) Or _
  465.                 Abs(cfNoVerticalFonts * CF_NOVERTFONTS)) Or _
  466.                 CF_ENABLEHOOK
  467.         .hwndOwner = cfhWndOwner
  468.         .lpfnHook = GetProc(AddressOf CommonDialogsHooks.ChooseFontProc)
  469.         .lpLogFont = VarPtr(cfLogFont)
  470.         .lStructSize = Len(cfChooseFont)
  471.         .nSizeMax = cfMaximumSize
  472.         .nSizeMin = cfMinimumSize
  473.         .rgbColors = cfFontColor
  474.     End With
  475.     
  476.     cfOK = CBool(ChooseFont(cfChooseFont))
  477.     cfCancel = Not (cfOK)
  478.     cfFontColor = cfChooseFont.rgbColors
  479.     
  480.     If cfCancel Then cfLogFont = SaveLogFont
  481. End Sub
  482.  
  483. Private Sub Class_Initialize()
  484.     CommonDialogsHooks.CFDialogTitle = "Font"
  485.     CommonDialogsHooks.CFOKButtonCaption = "OK"
  486.     CommonDialogsHooks.CFCancelButtonCaption = "Cancel"
  487.     CommonDialogsHooks.CFEnableColorComboBox = True
  488. End Sub
  489.